home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / FORTRAN2.LZH / OPERW.FOR < prev    next >
Encoding:
Text File  |  1988-02-08  |  3.5 KB  |  120 lines
  1.       SUBROUTINE OPERW ( MESSAG, WHO, REPLY )
  2. C*
  3. C*                  *******************************
  4. C*                  *******************************
  5. C*                  **                           **
  6. C*                  **          OPERW            **
  7. C*                  **                           **
  8. C*                  *******************************
  9. C*                  *******************************
  10. C*
  11. C*     SUBPROGRAM :
  12. C*          OPERATOR MESSAGE/WAIT FOR REPLY
  13. C*
  14. C*     AUTHOR :
  15. C*          ART RAGOSTA
  16. C*          MS 207-5
  17. C*          AMES RESEARCH CENTER
  18. C*          MOFFETT FIELD, CA   94035
  19. C*          (415) 694-5578
  20. C*
  21. C*     PURPOSE :
  22. C*          TO SEND A MESSAGE TO AN OPERATOR'S CONSOLE AND WAIT FOR A
  23. C*          REPLY.
  24. C*
  25. C*     INPUT ARGUMENTS :
  26. C*          MESSAG - THE TEXT OF THE MESSAGE TO BE SENT
  27. C*          WHO    - THE OPERATOR TO RECEIVE THE MESSAGE (EG,'CENTRAL','TAPES')
  28. C*
  29. C*     OUTPUT ARGUMENTS :
  30. C*          REPLY - THE TEXT STRING ENTERED BY THE OPERATOR, OR AN ERROR
  31. C*                   MESSAGE(FIRST WORD IS 'ERROR')
  32. C*
  33. C*     INTERNAL WORK AREAS :
  34. C*          MSGBUF - THE BUFFER FOR THE MESSAGE AND COMMAND CODES
  35. C*          OPER,IOPER - THE OPERATOR TARGET CODES IN ASCII AND BINARY
  36. C*
  37. C*     COMMON BLOCKS :
  38. C*          NONE
  39. C*
  40. C*     FILE REFERENCES :
  41. C*          0 - READ FROM MAILBOX
  42. C*
  43. C*     SUBPROGRAM REFERENCES :
  44. C*          SYS$SNDOPR, SYS$CREMBX, SYS$DASSGN
  45. C*
  46. C*     ERROR PROCESSING :
  47. C*          THE STATUS OF THE PREVIOUS SYSTEM SERVICE CALL IS CHECKED
  48. C*          BEFORE CONTINUING.
  49. C*
  50. C*     TRANSPORTABILITY LIMITATIONS :
  51. C*          HIGHLY NON-TRANSPORTABLE
  52. C*
  53. C*     ASSUMPTIONS AND RESTRICTIONS :
  54. C*          NO CHECK IS PERFORMED TO SEE IF 'WHO' IS VALID
  55. C*
  56. C*     LANGUAGE AND COMPILER :
  57. C*          ANSI FORTRAN 77
  58. C*
  59. C*     VERSION AND DATE :
  60. C*          VERSION I.0     25-JUL-85
  61. C*
  62. C*     CHANGE HISTORY :
  63. C*          25-JUL-85    INITIAL VERSION
  64. C*
  65. C***********************************************************************
  66. C*
  67.       CHARACTER *(*) MESSAG, WHO, REPLY
  68.       CHARACTER *132 MSGBUF
  69.       CHARACTER *2 OPERS(11), DUMMY
  70.       INTEGER *2 IOPER(11), IDUMMY
  71.       EQUIVALENCE (DUMMY,IDUMMY)
  72. C
  73. C --- OPERATOR TARGET CODES FROM SYSLIB:STARLET($OPCDEF)
  74. C
  75.       DATA OPERS/'CE','PR','TA','DI','DE','CA','NT','CL','SE','RE','NE'/
  76.       DATA IOPER/ 1,   2,   4,   8,   16,  32,  64, 128, 256, 512,  64/
  77. C
  78. C --- TO WHOM DO WE SEND THE MESSAGE ?
  79. C
  80.       DO 10 I = 1,11
  81.          IF (WHO(1:2) .EQ. OPERS(I)) GO TO 20
  82. 10       CONTINUE
  83.       I = 1
  84. C
  85. 20    MSGBUF(1:1) = CHAR(3)           ! REQUEST ALWAYS
  86.       IDUMMY = IOPER(I)
  87.       MSGBUF(2:2) = CHAR(0)
  88.       MSGBUF(3:4) = DUMMY             ! OPERATOR TARGET CODE
  89.       MSGBUF(5:8) = '    '
  90.       MSGBUF(9:132) = MESSAG          ! USER'S MESSAGE
  91. C
  92. C --- OPEN MAILBOX FOR REPLY
  93. C
  94.       ISTAT = SYS$CREMBX ( ,ICHAN,,,,, 'OPERMBX' )
  95.       IF ( ISTAT .NE. 0 ) THEN
  96.          REPLY = 'ERROR OPENING MAILBOX'
  97.          RETURN
  98.       ENDIF
  99. C
  100. C --- SEND THE MESSAGE
  101. C
  102.       ISTAT = SYS$SNDOPR(MSGBUF,%VAL(ICHAN))
  103.       IF ( ISTAT .NE. 0 ) THEN
  104.          REPLY = 'ERROR OPENING MAILBOX'
  105.          RETURN
  106.       ENDIF
  107.       OPEN (UNIT=0,NAME='OPERMBX',TYPE='OLD')
  108.       READ(0,900,END=100,ERR=100) MSGBUF
  109.       GO TO 200
  110. 100   REPLY = 'ERROR GETTING OPERATOR REPLY'
  111. 200   CLOSE(UNIT=0)
  112.       ISTAT = SYS$DASSGN(%VAL(ICHAN))
  113.       REPLY = MSGBUF(9:132)
  114.       RETURN
  115. 900   FORMAT(A)
  116.       END
  117. C
  118. C---END OPERW
  119. C
  120.